home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / cl-seq.el.z / cl-seq.el
Encoding:
Text File  |  1998-10-28  |  36.7 KB  |  920 lines
  1. ;;; cl-seq.el --- Common Lisp extensions for GNU Emacs Lisp (part three)
  2.  
  3. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Dave Gillespie <daveg@synaptics.com>
  6. ;; Version: 2.02
  7. ;; Keywords: extensions
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; These are extensions to Emacs Lisp that provide a degree of
  29. ;; Common Lisp compatibility, beyond what is already built-in
  30. ;; in Emacs Lisp.
  31. ;;
  32. ;; This package was written by Dave Gillespie; it is a complete
  33. ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
  34. ;;
  35. ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
  36. ;;
  37. ;; Bug reports, comments, and suggestions are welcome!
  38.  
  39. ;; This file contains the Common Lisp sequence and list functions
  40. ;; which take keyword arguments.
  41.  
  42. ;; See cl.el for Change Log.
  43.  
  44.  
  45. ;;; Code:
  46.  
  47. (or (memq 'cl-19 features)
  48.     (error "Tried to load `cl-seq' before `cl'!"))
  49.  
  50.  
  51. ;;; We define these here so that this file can compile without having
  52. ;;; loaded the cl.el file already.
  53.  
  54. (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
  55. (defmacro cl-pop (place)
  56.   (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
  57.  
  58.  
  59. ;;; Keyword parsing.  This is special-cased here so that we can compile
  60. ;;; this file independent from cl-macs.
  61.  
  62. (defmacro cl-parsing-keywords (kwords other-keys &rest body)
  63.   (cons
  64.    'let*
  65.    (cons (mapcar
  66.       (function
  67.        (lambda (x)
  68.          (let* ((var (if (consp x) (car x) x))
  69.             (mem (list 'car (list 'cdr (list 'memq (list 'quote var)
  70.                              'cl-keys)))))
  71.            (if (eq var ':test-not)
  72.            (setq mem (list 'and mem (list 'setq 'cl-test mem) t)))
  73.            (if (eq var ':if-not)
  74.            (setq mem (list 'and mem (list 'setq 'cl-if mem) t)))
  75.            (list (intern
  76.               (format "cl-%s" (substring (symbol-name var) 1)))
  77.              (if (consp x) (list 'or mem (car (cdr x))) mem)))))
  78.       kwords)
  79.      (append
  80.       (and (not (eq other-keys t))
  81.            (list
  82.         (list 'let '((cl-keys-temp cl-keys))
  83.               (list 'while 'cl-keys-temp
  84.                 (list 'or (list 'memq '(car cl-keys-temp)
  85.                         (list 'quote
  86.                           (mapcar
  87.                            (function
  88.                             (lambda (x)
  89.                               (if (consp x)
  90.                               (car x) x)))
  91.                            (append kwords
  92.                                other-keys))))
  93.                   '(car (cdr (memq (quote :allow-other-keys)
  94.                            cl-keys)))
  95.                   '(error "Bad keyword argument %s"
  96.                       (car cl-keys-temp)))
  97.                 '(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
  98.       body))))
  99. (put 'cl-parsing-keywords 'lisp-indent-function 2)
  100. (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
  101.  
  102. (defmacro cl-check-key (x)
  103.   (list 'if 'cl-key (list 'funcall 'cl-key x) x))
  104.  
  105. (defmacro cl-check-test-nokey (item x)
  106.   (list 'cond
  107.     (list 'cl-test
  108.           (list 'eq (list 'not (list 'funcall 'cl-test item x))
  109.             'cl-test-not))
  110.     (list 'cl-if
  111.           (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not))
  112.     (list 't (list 'if (list 'numberp item)
  113.                (list 'equal item x) (list 'eq item x)))))
  114.  
  115. (defmacro cl-check-test (item x)
  116.   (list 'cl-check-test-nokey item (list 'cl-check-key x)))
  117.  
  118. (defmacro cl-check-match (x y)
  119.   (setq x (list 'cl-check-key x) y (list 'cl-check-key y))
  120.   (list 'if 'cl-test
  121.     (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
  122.     (list 'if (list 'numberp x)
  123.           (list 'equal x y) (list 'eq x y))))
  124.  
  125. (put 'cl-check-key 'edebug-form-spec 'edebug-forms)
  126. (put 'cl-check-test 'edebug-form-spec 'edebug-forms)
  127. (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
  128. (put 'cl-check-match 'edebug-form-spec 'edebug-forms)
  129.  
  130. (defvar cl-test) (defvar cl-test-not)
  131. (defvar cl-if) (defvar cl-if-not)
  132. (defvar cl-key)
  133.  
  134.  
  135. (defun reduce (cl-func cl-seq &rest cl-keys)
  136.   "Reduce two-argument FUNCTION across SEQUENCE.
  137. Keywords supported:  :start :end :from-end :initial-value :key"
  138.   (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
  139.     (or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
  140.     (setq cl-seq (subseq cl-seq cl-start cl-end))
  141.     (if cl-from-end (setq cl-seq (nreverse cl-seq)))
  142.     (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value)
  143.               (cl-seq (cl-check-key (cl-pop cl-seq)))
  144.               (t (funcall cl-func)))))
  145.       (if cl-from-end
  146.       (while cl-seq
  147.         (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq))
  148.                     cl-accum)))
  149.     (while cl-seq
  150.       (setq cl-accum (funcall cl-func cl-accum
  151.                   (cl-check-key (cl-pop cl-seq))))))
  152.       cl-accum)))
  153.  
  154. (defun fill (seq item &rest cl-keys)
  155.   "Fill the elements of SEQ with ITEM.
  156. Keywords supported:  :start :end"
  157.   (cl-parsing-keywords ((:start 0) :end) ()
  158.     (if (listp seq)
  159.     (let ((p (nthcdr cl-start seq))
  160.           (n (if cl-end (- cl-end cl-start) 8000000)))
  161.       (while (and p (>= (setq n (1- n)) 0))
  162.         (setcar p item)
  163.         (setq p (cdr p))))
  164.       (or cl-end (setq cl-end (length seq)))
  165.       (if (and (= cl-start 0) (= cl-end (length seq)))
  166.       (fillarray seq item)
  167.     (while (< cl-start cl-end)
  168.       (aset seq cl-start item)
  169.       (setq cl-start (1+ cl-start)))))
  170.     seq))
  171.  
  172. (defun replace (cl-seq1 cl-seq2 &rest cl-keys)
  173.   "Replace the elements of SEQ1 with the elements of SEQ2.
  174. SEQ1 is destructively modified, then returned.
  175. Keywords supported:  :start1 :end1 :start2 :end2"
  176.   (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
  177.     (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
  178.     (or (= cl-start1 cl-start2)
  179.         (let* ((cl-len (length cl-seq1))
  180.            (cl-n (min (- (or cl-end1 cl-len) cl-start1)
  181.                   (- (or cl-end2 cl-len) cl-start2))))
  182.           (while (>= (setq cl-n (1- cl-n)) 0)
  183.         (cl-set-elt cl-seq1 (+ cl-start1 cl-n)
  184.                 (elt cl-seq2 (+ cl-start2 cl-n))))))
  185.       (if (listp cl-seq1)
  186.       (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
  187.         (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000)))
  188.         (if (listp cl-seq2)
  189.         (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
  190.               (cl-n (min cl-n1
  191.                  (if cl-end2 (- cl-end2 cl-start2) 4000000))))
  192.           (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0))
  193.             (setcar cl-p1 (car cl-p2))
  194.             (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
  195.           (setq cl-end2 (min (or cl-end2 (length cl-seq2))
  196.                  (+ cl-start2 cl-n1)))
  197.           (while (and cl-p1 (< cl-start2 cl-end2))
  198.         (setcar cl-p1 (aref cl-seq2 cl-start2))
  199.         (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
  200.     (setq cl-end1 (min (or cl-end1 (length cl-seq1))
  201.                (+ cl-start1 (- (or cl-end2 (length cl-seq2))
  202.                        cl-start2))))
  203.     (if (listp cl-seq2)
  204.         (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
  205.           (while (< cl-start1 cl-end1)
  206.         (aset cl-seq1 cl-start1 (car cl-p2))
  207.         (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
  208.       (while (< cl-start1 cl-end1)
  209.         (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
  210.         (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
  211.     cl-seq1))
  212.  
  213. (defun remove* (cl-item cl-seq &rest cl-keys)
  214.   "Remove all occurrences of ITEM in SEQ.
  215. This is a non-destructive function; it makes a copy of SEQ if necessary
  216. to avoid corrupting the original SEQ.
  217. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  218.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
  219.             (:start 0) :end) ()
  220.     (if (<= (or cl-count (setq cl-count 8000000)) 0)
  221.     cl-seq
  222.       (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000)))
  223.       (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end
  224.                    cl-from-end)))
  225.         (if cl-i
  226.         (let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
  227.                      (append (if cl-from-end
  228.                          (list ':end (1+ cl-i))
  229.                            (list ':start cl-i))
  230.                          cl-keys))))
  231.           (if (listp cl-seq) cl-res
  232.             (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))
  233.           cl-seq))
  234.     (setq cl-end (- (or cl-end 8000000) cl-start))
  235.     (if (= cl-start 0)
  236.         (while (and cl-seq (> cl-end 0)
  237.             (cl-check-test cl-item (car cl-seq))
  238.             (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
  239.             (> (setq cl-count (1- cl-count)) 0))))
  240.     (if (and (> cl-count 0) (> cl-end 0))
  241.         (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq)
  242.               (setq cl-end (1- cl-end)) (cdr cl-seq))))
  243.           (while (and cl-p (> cl-end 0)
  244.               (not (cl-check-test cl-item (car cl-p))))
  245.         (setq cl-p (cdr cl-p) cl-end (1- cl-end)))
  246.           (if (and cl-p (> cl-end 0))
  247.           (nconc (ldiff cl-seq cl-p)
  248.              (if (= cl-count 1) (cdr cl-p)
  249.                (and (cdr cl-p)
  250.                 (apply 'delete* cl-item
  251.                        (copy-sequence (cdr cl-p))
  252.                        ':start 0 ':end (1- cl-end)
  253.                        ':count (1- cl-count) cl-keys))))
  254.         cl-seq))
  255.       cl-seq)))))
  256.  
  257. (defun remove-if (cl-pred cl-list &rest cl-keys)
  258.   "Remove all items satisfying PREDICATE in SEQ.
  259. This is a non-destructive function; it makes a copy of SEQ if necessary
  260. to avoid corrupting the original SEQ.
  261. Keywords supported:  :key :count :start :end :from-end"
  262.   (apply 'remove* nil cl-list ':if cl-pred cl-keys))
  263.  
  264. (defun remove-if-not (cl-pred cl-list &rest cl-keys)
  265.   "Remove all items not satisfying PREDICATE in SEQ.
  266. This is a non-destructive function; it makes a copy of SEQ if necessary
  267. to avoid corrupting the original SEQ.
  268. Keywords supported:  :key :count :start :end :from-end"
  269.   (apply 'remove* nil cl-list ':if-not cl-pred cl-keys))
  270.  
  271. (defun delete* (cl-item cl-seq &rest cl-keys)
  272.   "Remove all occurrences of ITEM in SEQ.
  273. This is a destructive function; it reuses the storage of SEQ whenever possible.
  274. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  275.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end
  276.             (:start 0) :end) ()
  277.     (if (<= (or cl-count (setq cl-count 8000000)) 0)
  278.     cl-seq
  279.       (if (listp cl-seq)
  280.       (if (and cl-from-end (< cl-count 4000000))
  281.           (let (cl-i)
  282.         (while (and (>= (setq cl-count (1- cl-count)) 0)
  283.                 (setq cl-i (cl-position cl-item cl-seq cl-start
  284.                             cl-end cl-from-end)))
  285.           (if (= cl-i 0) (setq cl-seq (cdr cl-seq))
  286.             (let ((cl-tail (nthcdr (1- cl-i) cl-seq)))
  287.               (setcdr cl-tail (cdr (cdr cl-tail)))))
  288.           (setq cl-end cl-i))
  289.         cl-seq)
  290.         (setq cl-end (- (or cl-end 8000000) cl-start))
  291.         (if (= cl-start 0)
  292.         (progn
  293.           (while (and cl-seq
  294.                   (> cl-end 0)
  295.                   (cl-check-test cl-item (car cl-seq))
  296.                   (setq cl-end (1- cl-end) cl-seq (cdr cl-seq))
  297.                   (> (setq cl-count (1- cl-count)) 0)))
  298.           (setq cl-end (1- cl-end)))
  299.           (setq cl-start (1- cl-start)))
  300.         (if (and (> cl-count 0) (> cl-end 0))
  301.         (let ((cl-p (nthcdr cl-start cl-seq)))
  302.           (while (and (cdr cl-p) (> cl-end 0))
  303.             (if (cl-check-test cl-item (car (cdr cl-p)))
  304.             (progn
  305.               (setcdr cl-p (cdr (cdr cl-p)))
  306.               (if (= (setq cl-count (1- cl-count)) 0)
  307.                   (setq cl-end 1)))
  308.               (setq cl-p (cdr cl-p)))
  309.             (setq cl-end (1- cl-end)))))
  310.         cl-seq)
  311.     (apply 'remove* cl-item cl-seq cl-keys)))))
  312.  
  313. (defun delete-if (cl-pred cl-list &rest cl-keys)
  314.   "Remove all items satisfying PREDICATE in SEQ.
  315. This is a destructive function; it reuses the storage of SEQ whenever possible.
  316. Keywords supported:  :key :count :start :end :from-end"
  317.   (apply 'delete* nil cl-list ':if cl-pred cl-keys))
  318.  
  319. (defun delete-if-not (cl-pred cl-list &rest cl-keys)
  320.   "Remove all items not satisfying PREDICATE in SEQ.
  321. This is a destructive function; it reuses the storage of SEQ whenever possible.
  322. Keywords supported:  :key :count :start :end :from-end"
  323.   (apply 'delete* nil cl-list ':if-not cl-pred cl-keys))
  324.  
  325. (or (and (fboundp 'delete) (subrp (symbol-function 'delete)))
  326.     (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal)))))
  327. (defun remove (x y) (remove* x y ':test 'equal))
  328. (defun remq (x y) (if (memq x y) (delq x (copy-list y)) y))
  329.  
  330. (defun remove-duplicates (cl-seq &rest cl-keys)
  331.   "Return a copy of SEQ with all duplicate elements removed.
  332. Keywords supported:  :test :test-not :key :start :end :from-end"
  333.   (cl-delete-duplicates cl-seq cl-keys t))
  334.  
  335. (defun delete-duplicates (cl-seq &rest cl-keys)
  336.   "Remove all duplicate elements from SEQ (destructively).
  337. Keywords supported:  :test :test-not :key :start :end :from-end"
  338.   (cl-delete-duplicates cl-seq cl-keys nil))
  339.  
  340. (defun cl-delete-duplicates (cl-seq cl-keys cl-copy)
  341.   (if (listp cl-seq)
  342.       (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if)
  343.       ()
  344.     (if cl-from-end
  345.         (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
  346.           (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
  347.           (while (> cl-end 1)
  348.         (setq cl-i 0)
  349.         (while (setq cl-i (cl-position (cl-check-key (car cl-p))
  350.                            (cdr cl-p) cl-i (1- cl-end)))
  351.           (if cl-copy (setq cl-seq (copy-sequence cl-seq)
  352.                     cl-p (nthcdr cl-start cl-seq) cl-copy nil))
  353.           (let ((cl-tail (nthcdr cl-i cl-p)))
  354.             (setcdr cl-tail (cdr (cdr cl-tail))))
  355.           (setq cl-end (1- cl-end)))
  356.         (setq cl-p (cdr cl-p) cl-end (1- cl-end)
  357.               cl-start (1+ cl-start)))
  358.           cl-seq)
  359.       (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
  360.       (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
  361.               (cl-position (cl-check-key (car cl-seq))
  362.                    (cdr cl-seq) 0 (1- cl-end)))
  363.         (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
  364.       (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
  365.             (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
  366.         (while (and (cdr (cdr cl-p)) (> cl-end 1))
  367.           (if (cl-position (cl-check-key (car (cdr cl-p)))
  368.                    (cdr (cdr cl-p)) 0 (1- cl-end))
  369.           (progn
  370.             (if cl-copy (setq cl-seq (copy-sequence cl-seq)
  371.                       cl-p (nthcdr (1- cl-start) cl-seq)
  372.                       cl-copy nil))
  373.             (setcdr cl-p (cdr (cdr cl-p))))
  374.         (setq cl-p (cdr cl-p)))
  375.           (setq cl-end (1- cl-end) cl-start (1+ cl-start)))
  376.         cl-seq)))
  377.     (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil)))
  378.       (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))))
  379.  
  380. (defun substitute (cl-new cl-old cl-seq &rest cl-keys)
  381.   "Substitute NEW for OLD in SEQ.
  382. This is a non-destructive function; it makes a copy of SEQ if necessary
  383. to avoid corrupting the original SEQ.
  384. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  385.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count
  386.             (:start 0) :end :from-end) ()
  387.     (if (or (eq cl-old cl-new)
  388.         (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0))
  389.     cl-seq
  390.       (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end)))
  391.     (if (not cl-i)
  392.         cl-seq
  393.       (setq cl-seq (copy-sequence cl-seq))
  394.       (or cl-from-end
  395.           (progn (cl-set-elt cl-seq cl-i cl-new)
  396.              (setq cl-i (1+ cl-i) cl-count (1- cl-count))))
  397.       (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count
  398.          ':start cl-i cl-keys))))))
  399.  
  400. (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
  401.   "Substitute NEW for all items satisfying PREDICATE in SEQ.
  402. This is a non-destructive function; it makes a copy of SEQ if necessary
  403. to avoid corrupting the original SEQ.
  404. Keywords supported:  :key :count :start :end :from-end"
  405.   (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys))
  406.  
  407. (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
  408.   "Substitute NEW for all items not satisfying PREDICATE in SEQ.
  409. This is a non-destructive function; it makes a copy of SEQ if necessary
  410. to avoid corrupting the original SEQ.
  411. Keywords supported:  :key :count :start :end :from-end"
  412.   (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys))
  413.  
  414. (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
  415.   "Substitute NEW for OLD in SEQ.
  416. This is a destructive function; it reuses the storage of SEQ whenever possible.
  417. Keywords supported:  :test :test-not :key :count :start :end :from-end"
  418.   (cl-parsing-keywords (:test :test-not :key :if :if-not :count
  419.             (:start 0) :end :from-end) ()
  420.     (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0)
  421.     (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000)))
  422.         (let ((cl-p (nthcdr cl-start cl-seq)))
  423.           (setq cl-end (- (or cl-end 8000000) cl-start))
  424.           (while (and cl-p (> cl-end 0) (> cl-count 0))
  425.         (if (cl-check-test cl-old (car cl-p))
  426.             (progn
  427.               (setcar cl-p cl-new)
  428.               (setq cl-count (1- cl-count))))
  429.         (setq cl-p (cdr cl-p) cl-end (1- cl-end))))
  430.       (or cl-end (setq cl-end (length cl-seq)))
  431.       (if cl-from-end
  432.           (while (and (< cl-start cl-end) (> cl-count 0))
  433.         (setq cl-end (1- cl-end))
  434.         (if (cl-check-test cl-old (elt cl-seq cl-end))
  435.             (progn
  436.               (cl-set-elt cl-seq cl-end cl-new)
  437.               (setq cl-count (1- cl-count)))))
  438.         (while (and (< cl-start cl-end) (> cl-count 0))
  439.           (if (cl-check-test cl-old (aref cl-seq cl-start))
  440.           (progn
  441.             (aset cl-seq cl-start cl-new)
  442.             (setq cl-count (1- cl-count))))
  443.           (setq cl-start (1+ cl-start))))))
  444.     cl-seq))
  445.  
  446. (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
  447.   "Substitute NEW for all items satisfying PREDICATE in SEQ.
  448. This is a destructive function; it reuses the storage of SEQ whenever possible.
  449. Keywords supported:  :key :count :start :end :from-end"
  450.   (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys))
  451.  
  452. (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
  453.   "Substitute NEW for all items not satisfying PREDICATE in SEQ.
  454. This is a destructive function; it reuses the storage of SEQ whenever possible.
  455. Keywords supported:  :key :count :start :end :from-end"
  456.   (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys))
  457.  
  458. (defun find (cl-item cl-seq &rest cl-keys)
  459.   "Find the first occurrence of ITEM in LIST.
  460. Return the matching ITEM, or nil if not found.
  461. Keywords supported:  :test :test-not :key :start :end :from-end"
  462.   (let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
  463.     (and cl-pos (elt cl-seq cl-pos))))
  464.  
  465. (defun find-if (cl-pred cl-list &rest cl-keys)
  466.   "Find the first item satisfying PREDICATE in LIST.
  467. Return the matching ITEM, or nil if not found.
  468. Keywords supported:  :key :start :end :from-end"
  469.   (apply 'find nil cl-list ':if cl-pred cl-keys))
  470.  
  471. (defun find-if-not (cl-pred cl-list &rest cl-keys)
  472.   "Find the first item not satisfying PREDICATE in LIST.
  473. Return the matching ITEM, or nil if not found.
  474. Keywords supported:  :key :start :end :from-end"
  475.   (apply 'find nil cl-list ':if-not cl-pred cl-keys))
  476.  
  477. (defun position (cl-item cl-seq &rest cl-keys)
  478.   "Find the first occurrence of ITEM in LIST.
  479. Return the index of the matching item, or nil if not found.
  480. Keywords supported:  :test :test-not :key :start :end :from-end"
  481.   (cl-parsing-keywords (:test :test-not :key :if :if-not
  482.             (:start 0) :end :from-end) ()
  483.     (cl-position cl-item cl-seq cl-start cl-end cl-from-end)))
  484.  
  485. (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
  486.   (if (listp cl-seq)
  487.       (let ((cl-p (nthcdr cl-start cl-seq)))
  488.     (or cl-end (setq cl-end 8000000))
  489.     (let ((cl-res nil))
  490.       (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end))
  491.         (if (cl-check-test cl-item (car cl-p))
  492.         (setq cl-res cl-start))
  493.         (setq cl-p (cdr cl-p) cl-start (1+ cl-start)))
  494.       cl-res))
  495.     (or cl-end (setq cl-end (length cl-seq)))
  496.     (if cl-from-end
  497.     (progn
  498.       (while (and (>= (setq cl-end (1- cl-end)) cl-start)
  499.               (not (cl-check-test cl-item (aref cl-seq cl-end)))))
  500.       (and (>= cl-end cl-start) cl-end))
  501.       (while (and (< cl-start cl-end)
  502.           (not (cl-check-test cl-item (aref cl-seq cl-start))))
  503.     (setq cl-start (1+ cl-start)))
  504.       (and (< cl-start cl-end) cl-start))))
  505.  
  506. (defun position-if (cl-pred cl-list &rest cl-keys)
  507.   "Find the first item satisfying PREDICATE in LIST.
  508. Return the index of the matching item, or nil if not found.
  509. Keywords supported:  :key :start :end :from-end"
  510.   (apply 'position nil cl-list ':if cl-pred cl-keys))
  511.  
  512. (defun position-if-not (cl-pred cl-list &rest cl-keys)
  513.   "Find the first item not satisfying PREDICATE in LIST.
  514. Return the index of the matching item, or nil if not found.
  515. Keywords supported:  :key :start :end :from-end"
  516.   (apply 'position nil cl-list ':if-not cl-pred cl-keys))
  517.  
  518. (defun count (cl-item cl-seq &rest cl-keys)
  519.   "Count the number of occurrences of ITEM in LIST.
  520. Keywords supported:  :test :test-not :key :start :end"
  521.   (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
  522.     (let ((cl-count 0) cl-x)
  523.       (or cl-end (setq cl-end (length cl-seq)))
  524.       (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
  525.       (while (< cl-start cl-end)
  526.     (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start)))
  527.     (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count)))
  528.     (setq cl-start (1+ cl-start)))
  529.       cl-count)))
  530.  
  531. (defun count-if (cl-pred cl-list &rest cl-keys)
  532.   "Count the number of items satisfying PREDICATE in LIST.
  533. Keywords supported:  :key :start :end"
  534.   (apply 'count nil cl-list ':if cl-pred cl-keys))
  535.  
  536. (defun count-if-not (cl-pred cl-list &rest cl-keys)
  537.   "Count the number of items not satisfying PREDICATE in LIST.
  538. Keywords supported:  :key :start :end"
  539.   (apply 'count nil cl-list ':if-not cl-pred cl-keys))
  540.  
  541. (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
  542.   "Compare SEQ1 with SEQ2, return index of first mismatching element.
  543. Return nil if the sequences match.  If one sequence is a prefix of the
  544. other, the return value indicates the end of the shorted sequence.
  545. Keywords supported:  :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
  546.   (cl-parsing-keywords (:test :test-not :key :from-end
  547.             (:start1 0) :end1 (:start2 0) :end2) ()
  548.     (or cl-end1 (setq cl-end1 (length cl-seq1)))
  549.     (or cl-end2 (setq cl-end2 (length cl-seq2)))
  550.     (if cl-from-end
  551.     (progn
  552.       (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
  553.               (cl-check-match (elt cl-seq1 (1- cl-end1))
  554.                       (elt cl-seq2 (1- cl-end2))))
  555.         (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
  556.       (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
  557.            (1- cl-end1)))
  558.       (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
  559.         (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
  560.     (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
  561.             (cl-check-match (if cl-p1 (car cl-p1)
  562.                       (aref cl-seq1 cl-start1))
  563.                     (if cl-p2 (car cl-p2)
  564.                       (aref cl-seq2 cl-start2))))
  565.       (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
  566.         cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
  567.     (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
  568.          cl-start1)))))
  569.  
  570. (defun search (cl-seq1 cl-seq2 &rest cl-keys)
  571.   "Search for SEQ1 as a subsequence of SEQ2.
  572. Return the index of the leftmost element of the first match found;
  573. return nil if there are no matches.
  574. Keywords supported:  :test :test-not :key :start1 :end1 :start2 :end2 :from-end"
  575.   (cl-parsing-keywords (:test :test-not :key :from-end
  576.             (:start1 0) :end1 (:start2 0) :end2) ()
  577.     (or cl-end1 (setq cl-end1 (length cl-seq1)))
  578.     (or cl-end2 (setq cl-end2 (length cl-seq2)))
  579.     (if (>= cl-start1 cl-end1)
  580.     (if cl-from-end cl-end2 cl-start2)
  581.       (let* ((cl-len (- cl-end1 cl-start1))
  582.          (cl-first (cl-check-key (elt cl-seq1 cl-start1)))
  583.          (cl-if nil) cl-pos)
  584.     (setq cl-end2 (- cl-end2 (1- cl-len)))
  585.     (while (and (< cl-start2 cl-end2)
  586.             (setq cl-pos (cl-position cl-first cl-seq2
  587.                           cl-start2 cl-end2 cl-from-end))
  588.             (apply 'mismatch cl-seq1 cl-seq2
  589.                ':start1 (1+ cl-start1) ':end1 cl-end1
  590.                ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len)
  591.                ':from-end nil cl-keys))
  592.       (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
  593.     (and (< cl-start2 cl-end2) cl-pos)))))
  594.  
  595. (defun sort* (cl-seq cl-pred &rest cl-keys)
  596.   "Sort the argument SEQUENCE according to PREDICATE.
  597. This is a destructive function; it reuses the storage of SEQUENCE if possible.
  598. Keywords supported:  :key"
  599.   (if (nlistp cl-seq)
  600.       (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys))
  601.     (cl-parsing-keywords (:key) ()
  602.       (if (memq cl-key '(nil identity))
  603.       (sort cl-seq cl-pred)
  604.     (sort cl-seq (function (lambda (cl-x cl-y)
  605.                  (funcall cl-pred (funcall cl-key cl-x)
  606.                       (funcall cl-key cl-y)))))))))
  607.  
  608. (defun stable-sort (cl-seq cl-pred &rest cl-keys)
  609.   "Sort the argument SEQUENCE stably according to PREDICATE.
  610. This is a destructive function; it reuses the storage of SEQUENCE if possible.
  611. Keywords supported:  :key"
  612.   (apply 'sort* cl-seq cl-pred cl-keys))
  613.  
  614. (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
  615.   "Destructively merge the two sequences to produce a new sequence.
  616. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two
  617. argument sequences, and PRED is a `less-than' predicate on the elements.
  618. Keywords supported:  :key"
  619.   (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil)))
  620.   (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil)))
  621.   (cl-parsing-keywords (:key) ()
  622.     (let ((cl-res nil))
  623.       (while (and cl-seq1 cl-seq2)
  624.     (if (funcall cl-pred (cl-check-key (car cl-seq2))
  625.              (cl-check-key (car cl-seq1)))
  626.         (cl-push (cl-pop cl-seq2) cl-res)
  627.       (cl-push (cl-pop cl-seq1) cl-res)))
  628.       (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
  629.  
  630. ;;; See compiler macro in cl-macs.el
  631. (defun member* (cl-item cl-list &rest cl-keys)
  632.   "Find the first occurrence of ITEM in LIST.
  633. Return the sublist of LIST whose car is ITEM.
  634. Keywords supported:  :test :test-not :key"
  635.   (if cl-keys
  636.       (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  637.     (while (and cl-list (not (cl-check-test cl-item (car cl-list))))
  638.       (setq cl-list (cdr cl-list)))
  639.     cl-list)
  640.     (if (and (numberp cl-item) (not (integerp cl-item)))
  641.     (member cl-item cl-list)
  642.       (memq cl-item cl-list))))
  643.  
  644. (defun member-if (cl-pred cl-list &rest cl-keys)
  645.   "Find the first item satisfying PREDICATE in LIST.
  646. Return the sublist of LIST whose car matches.
  647. Keywords supported:  :key"
  648.   (apply 'member* nil cl-list ':if cl-pred cl-keys))
  649.  
  650. (defun member-if-not (cl-pred cl-list &rest cl-keys)
  651.   "Find the first item not satisfying PREDICATE in LIST.
  652. Return the sublist of LIST whose car matches.
  653. Keywords supported:  :key"
  654.   (apply 'member* nil cl-list ':if-not cl-pred cl-keys))
  655.  
  656. (defun cl-adjoin (cl-item cl-list &rest cl-keys)
  657.   (if (cl-parsing-keywords (:key) t
  658.     (apply 'member* (cl-check-key cl-item) cl-list cl-keys))
  659.       cl-list
  660.     (cons cl-item cl-list)))
  661.  
  662. ;;; See compiler macro in cl-macs.el
  663. (defun assoc* (cl-item cl-alist &rest cl-keys)
  664.   "Find the first item whose car matches ITEM in LIST.
  665. Keywords supported:  :test :test-not :key"
  666.   (if cl-keys
  667.       (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  668.     (while (and cl-alist
  669.             (or (not (consp (car cl-alist)))
  670.             (not (cl-check-test cl-item (car (car cl-alist))))))
  671.       (setq cl-alist (cdr cl-alist)))
  672.     (and cl-alist (car cl-alist)))
  673.     (if (and (numberp cl-item) (not (integerp cl-item)))
  674.     (assoc cl-item cl-alist)
  675.       (assq cl-item cl-alist))))
  676.  
  677. (defun assoc-if (cl-pred cl-list &rest cl-keys)
  678.   "Find the first item whose car satisfies PREDICATE in LIST.
  679. Keywords supported:  :key"
  680.   (apply 'assoc* nil cl-list ':if cl-pred cl-keys))
  681.  
  682. (defun assoc-if-not (cl-pred cl-list &rest cl-keys)
  683.   "Find the first item whose car does not satisfy PREDICATE in LIST.
  684. Keywords supported:  :key"
  685.   (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys))
  686.  
  687. (defun rassoc* (cl-item cl-alist &rest cl-keys)
  688.   "Find the first item whose cdr matches ITEM in LIST.
  689. Keywords supported:  :test :test-not :key"
  690.   (if (or cl-keys (numberp cl-item))
  691.       (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  692.     (while (and cl-alist
  693.             (or (not (consp (car cl-alist)))
  694.             (not (cl-check-test cl-item (cdr (car cl-alist))))))
  695.       (setq cl-alist (cdr cl-alist)))
  696.     (and cl-alist (car cl-alist)))
  697.     (rassq cl-item cl-alist)))
  698.  
  699. (defun rassoc-if (cl-pred cl-list &rest cl-keys)
  700.   "Find the first item whose cdr satisfies PREDICATE in LIST.
  701. Keywords supported:  :key"
  702.   (apply 'rassoc* nil cl-list ':if cl-pred cl-keys))
  703.  
  704. (defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
  705.   "Find the first item whose cdr does not satisfy PREDICATE in LIST.
  706. Keywords supported:  :key"
  707.   (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys))
  708.  
  709. (defun union (cl-list1 cl-list2 &rest cl-keys)
  710.   "Combine LIST1 and LIST2 using a set-union operation.
  711. The result list contains all items that appear in either LIST1 or LIST2.
  712. This is a non-destructive function; it makes a copy of the data if necessary
  713. to avoid corrupting the original LIST1 and LIST2.
  714. Keywords supported:  :test :test-not :key"
  715.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  716.     ((equal cl-list1 cl-list2) cl-list1)
  717.     (t
  718.      (or (>= (length cl-list1) (length cl-list2))
  719.          (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
  720.      (while cl-list2
  721.        (if (or cl-keys (numberp (car cl-list2)))
  722.            (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
  723.          (or (memq (car cl-list2) cl-list1)
  724.          (cl-push (car cl-list2) cl-list1)))
  725.        (cl-pop cl-list2))
  726.      cl-list1)))
  727.  
  728. (defun nunion (cl-list1 cl-list2 &rest cl-keys)
  729.   "Combine LIST1 and LIST2 using a set-union operation.
  730. The result list contains all items that appear in either LIST1 or LIST2.
  731. This is a destructive function; it reuses the storage of LIST1 and LIST2
  732. whenever possible.
  733. Keywords supported:  :test :test-not :key"
  734.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  735.     (t (apply 'union cl-list1 cl-list2 cl-keys))))
  736.  
  737. (defun intersection (cl-list1 cl-list2 &rest cl-keys)
  738.   "Combine LIST1 and LIST2 using a set-intersection operation.
  739. The result list contains all items that appear in both LIST1 and LIST2.
  740. This is a non-destructive function; it makes a copy of the data if necessary
  741. to avoid corrupting the original LIST1 and LIST2.
  742. Keywords supported:  :test :test-not :key"
  743.   (and cl-list1 cl-list2
  744.        (if (equal cl-list1 cl-list2) cl-list1
  745.      (cl-parsing-keywords (:key) (:test :test-not)
  746.        (let ((cl-res nil))
  747.          (or (>= (length cl-list1) (length cl-list2))
  748.          (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
  749.          (while cl-list2
  750.            (if (if (or cl-keys (numberp (car cl-list2)))
  751.                (apply 'member* (cl-check-key (car cl-list2))
  752.                   cl-list1 cl-keys)
  753.              (memq (car cl-list2) cl-list1))
  754.            (cl-push (car cl-list2) cl-res))
  755.            (cl-pop cl-list2))
  756.          cl-res)))))
  757.  
  758. (defun nintersection (cl-list1 cl-list2 &rest cl-keys)
  759.   "Combine LIST1 and LIST2 using a set-intersection operation.
  760. The result list contains all items that appear in both LIST1 and LIST2.
  761. This is a destructive function; it reuses the storage of LIST1 and LIST2
  762. whenever possible.
  763. Keywords supported:  :test :test-not :key"
  764.   (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
  765.  
  766. (defun set-difference (cl-list1 cl-list2 &rest cl-keys)
  767.   "Combine LIST1 and LIST2 using a set-difference operation.
  768. The result list contains all items that appear in LIST1 but not LIST2.
  769. This is a non-destructive function; it makes a copy of the data if necessary
  770. to avoid corrupting the original LIST1 and LIST2.
  771. Keywords supported:  :test :test-not :key"
  772.   (if (or (null cl-list1) (null cl-list2)) cl-list1
  773.     (cl-parsing-keywords (:key) (:test :test-not)
  774.       (let ((cl-res nil))
  775.     (while cl-list1
  776.       (or (if (or cl-keys (numberp (car cl-list1)))
  777.           (apply 'member* (cl-check-key (car cl-list1))
  778.              cl-list2 cl-keys)
  779.         (memq (car cl-list1) cl-list2))
  780.           (cl-push (car cl-list1) cl-res))
  781.       (cl-pop cl-list1))
  782.     cl-res))))
  783.  
  784. (defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
  785.   "Combine LIST1 and LIST2 using a set-difference operation.
  786. The result list contains all items that appear in LIST1 but not LIST2.
  787. This is a destructive function; it reuses the storage of LIST1 and LIST2
  788. whenever possible.
  789. Keywords supported:  :test :test-not :key"
  790.   (if (or (null cl-list1) (null cl-list2)) cl-list1
  791.     (apply 'set-difference cl-list1 cl-list2 cl-keys)))
  792.  
  793. (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
  794.   "Combine LIST1 and LIST2 using a set-exclusive-or operation.
  795. The result list contains all items that appear in exactly one of LIST1, LIST2.
  796. This is a non-destructive function; it makes a copy of the data if necessary
  797. to avoid corrupting the original LIST1 and LIST2.
  798. Keywords supported:  :test :test-not :key"
  799.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  800.     ((equal cl-list1 cl-list2) nil)
  801.     (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
  802.            (apply 'set-difference cl-list2 cl-list1 cl-keys)))))
  803.  
  804. (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
  805.   "Combine LIST1 and LIST2 using a set-exclusive-or operation.
  806. The result list contains all items that appear in exactly one of LIST1, LIST2.
  807. This is a destructive function; it reuses the storage of LIST1 and LIST2
  808. whenever possible.
  809. Keywords supported:  :test :test-not :key"
  810.   (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
  811.     ((equal cl-list1 cl-list2) nil)
  812.     (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
  813.           (apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
  814.  
  815. (defun subsetp (cl-list1 cl-list2 &rest cl-keys)
  816.   "True if LIST1 is a subset of LIST2.
  817. I.e., if every element of LIST1 also appears in LIST2.
  818. Keywords supported:  :test :test-not :key"
  819.   (cond ((null cl-list1) t) ((null cl-list2) nil)
  820.     ((equal cl-list1 cl-list2) t)
  821.     (t (cl-parsing-keywords (:key) (:test :test-not)
  822.          (while (and cl-list1
  823.              (apply 'member* (cl-check-key (car cl-list1))
  824.                 cl-list2 cl-keys))
  825.            (cl-pop cl-list1))
  826.          (null cl-list1)))))
  827.  
  828. (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
  829.   "Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
  830. Return a copy of TREE with all matching elements replaced by NEW.
  831. Keywords supported:  :key"
  832.   (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys))
  833.  
  834. (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
  835.   "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
  836. Return a copy of TREE with all non-matching elements replaced by NEW.
  837. Keywords supported:  :key"
  838.   (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys))
  839.  
  840. (defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
  841.   "Substitute NEW for OLD everywhere in TREE (destructively).
  842. Any element of TREE which is `eql' to OLD is changed to NEW (via a call
  843. to `setcar').
  844. Keywords supported:  :test :test-not :key"
  845.   (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
  846.  
  847. (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
  848.   "Substitute NEW for elements matching PREDICATE in TREE (destructively).
  849. Any element of TREE which matches is changed to NEW (via a call to `setcar').
  850. Keywords supported:  :key"
  851.   (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys))
  852.  
  853. (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
  854.   "Substitute NEW for elements not matching PREDICATE in TREE (destructively).
  855. Any element of TREE which matches is changed to NEW (via a call to `setcar').
  856. Keywords supported:  :key"
  857.   (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys))
  858.  
  859. (defun sublis (cl-alist cl-tree &rest cl-keys)
  860.   "Perform substitutions indicated by ALIST in TREE (non-destructively).
  861. Return a copy of TREE with all matching elements replaced.
  862. Keywords supported:  :test :test-not :key"
  863.   (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  864.     (cl-sublis-rec cl-tree)))
  865.  
  866. (defvar cl-alist)
  867. (defun cl-sublis-rec (cl-tree)   ; uses cl-alist/key/test*/if*
  868.   (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist))
  869.     (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  870.       (setq cl-p (cdr cl-p)))
  871.     (if cl-p (cdr (car cl-p))
  872.       (if (consp cl-tree)
  873.       (let ((cl-a (cl-sublis-rec (car cl-tree)))
  874.         (cl-d (cl-sublis-rec (cdr cl-tree))))
  875.         (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree)))
  876.         cl-tree
  877.           (cons cl-a cl-d)))
  878.     cl-tree))))
  879.  
  880. (defun nsublis (cl-alist cl-tree &rest cl-keys)
  881.   "Perform substitutions indicated by ALIST in TREE (destructively).
  882. Any matching element of TREE is changed via a call to `setcar'.
  883. Keywords supported:  :test :test-not :key"
  884.   (cl-parsing-keywords (:test :test-not :key :if :if-not) ()
  885.     (let ((cl-hold (list cl-tree)))
  886.       (cl-nsublis-rec cl-hold)
  887.       (car cl-hold))))
  888.  
  889. (defun cl-nsublis-rec (cl-tree)   ; uses cl-alist/temp/p/key/test*/if*
  890.   (while (consp cl-tree)
  891.     (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist))
  892.       (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  893.     (setq cl-p (cdr cl-p)))
  894.       (if cl-p (setcar cl-tree (cdr (car cl-p)))
  895.     (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree))))
  896.       (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist)
  897.       (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp)))
  898.     (setq cl-p (cdr cl-p)))
  899.       (if cl-p
  900.       (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
  901.     (setq cl-tree (cdr cl-tree))))))
  902.  
  903. (defun tree-equal (cl-x cl-y &rest cl-keys)
  904.   "T if trees X and Y have `eql' leaves.
  905. Atoms are compared by `eql'; cons cells are compared recursively.
  906. Keywords supported:  :test :test-not :key"
  907.   (cl-parsing-keywords (:test :test-not :key) ()
  908.     (cl-tree-equal-rec cl-x cl-y)))
  909.  
  910. (defun cl-tree-equal-rec (cl-x cl-y)
  911.   (while (and (consp cl-x) (consp cl-y)
  912.           (cl-tree-equal-rec (car cl-x) (car cl-y)))
  913.     (setq cl-x (cdr cl-x) cl-y (cdr cl-y)))
  914.   (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y)))
  915.  
  916.  
  917. (run-hooks 'cl-seq-load-hook)
  918.  
  919. ;;; cl-seq.el ends here
  920.